Многозвенная цепь
processVertices[vertices_List, fixed_List, bonds_List] := Module[{
coords = vertices[[1]],
coords2 = vertices[[2]],
coords3 = vertices[[3]]
},
Do[
coords3 = coords2;
coords2 = coords;
Module[{
integrated = 2 coords2 - coords3 + Table[{0,-1}, Length[coords]] 0.001
},
MapThread[Function[{i,j,l,s}, With[{
d = integrated[[i]] - integrated[[j]]
},{
norm = Norm[d]
},{
m = 0.5 s Min[(l/(norm+0.001) - 1), 0.1]
(* чтобы не взорвалось при больших ударах *)
},
integrated[[i]] += m d;
integrated[[j]] -= m d;
]], RandomSample[bonds]// Transpose];
Map[Function[index,
integrated[[index]] = coords[[index]];
], fixed];
coords = integrated;
];
, {2 5}];
{coords, coords2, coords3}
]
springs = {{1,2,1,1}, {2,3,1,1}, {3,4,1,1}, {4,5,1,1}};
vertices = Table[{i,0}, {i,0,4}];
fixed = {1};
estimate[t_Integer, vertices_, fixed_, springs_] := FixedPoint[Function[x,
processVertices[x, fixed, springs]
], {
vertices,
vertices,
vertices
}, t];
With[{vertices= vertices, fixed=fixed, springs=springs}, Animate[Graphics[{
Line[estimate[n, vertices, fixed, springs][[1]]]
}, PlotRange->{{-5,5}, {-5,5}}], {n, 1, 100, 1}] ]
Разветвленные звенья
vertices = {{-0.6864864864864866`,0.7375`},{-0.16756756756756758`,0.7483108108108107`},{0.32432432432432434`,0.764527027027027`},{-0.5675675675675675`,0.6293918918918919`},{-0.22162162162162158`,0.6564189189189189`},{-0.06486486486486487`,0.6672297297297298`},{0.22162162162162158`,0.6726351351351352`},{0.037837837837837895`,0.6131756756756757`},{0.1351351351351351`,0.618581081081081`},{-0.3351351351351352`,0.5969594594594594`},{-0.4378378378378378`,0.591554054054054`},{-0.37837837837837845`,0.5158783783783782`},{0.09189189189189184`,0.5320945945945945`},{-0.30810810810810807`,0.45641891891891895`},{-0.21621621621621623`,0.4131756756756757`},{-0.1027027027027026`,0.4131756756756757`},{0.021621621621621623`,0.4672297297297297`},{-0.15135135135135136`,0.33209459459459456`},{-0.14594594594594584`,0.2564189189189188`},{-0.1405405405405405`,0.17533783783783785`},{-0.12972972972972974`,0.10506756756756758`},{-0.6432432432432433`,0.6888513513513512`},{-0.508108108108108`,0.6077702702702703`},{-0.17837837837837833`,0.7104729729729731`},{-0.2756756756756756`,0.618581081081081`},{-0.00540540540540535`,0.6402027027027026`},{-0.11891891891891898`,0.7050675675675675`},{0.18378378378378368`,0.6402027027027026`},{0.27567567567567575`,0.7266891891891891`},{0.09189189189189184`,0.591554054054054`},{-0.3837837837837838`,0.5699324324324324`},{-0.1567567567567567`,0.3915540540540541`},{-0.34594594594594597`,0.4942567567567568`},{-0.2648648648648648`,0.4402027027027027`},{-0.03783783783783784`,0.4347972972972973`},{0.06486486486486487`,0.4996621621621622`}};
springs = Select[Select[Partition[Flatten[MapIndexed[Function[{pos, index},
Take[SortBy[MapIndexed[Function[{nextPos, nextIndex},
{index[[1]], nextIndex[[1]], Norm[nextPos - pos], 1.0}
], vertices], Function[i, i[[3]]] ], 3]
], vertices]], 4], Function[x, x[[1]] != x[[2]]]], ( #[[3]] < 0.1)&];
fixed = {1,2,3};
Graphics[Table[Line[{vertices[[s[[1]]]], vertices[[s[[2]]]]}], {s, springs}]]
With[{vertices= vertices, fixed=fixed, springs=springs},
Animate[
With[{v = estimate[n, vertices, fixed, springs]},
Graphics[{Blue, Line[Table[{v[[1, s[[1]]]], v[[1, s[[2]]]]}, {s, springs}]], Red, Point[vertices[[fixed]]]}]
], {n, 1, 20, 1}]]